(DEFPROP EXPANDFNS
 (EXPANDFNS RP
	    START
	    ARGLISTASK
	    GENAPPLY
	    GETDEF
	    FIXFN
	    UNFIXFN
	    ISFORM
	    GENEXPANSION
	    MAKELIST
	    GETVAL
	    KWOTE
	    MAKEMAKEFORM
	    TURNON
	    TURNOFF
	    NOFORMIN
	    STRUCINCL
	    STRUCINLIST
	    WHERE
	    PRINNUMLIS
	    STATE
	    MMAC
	    (EDITE MMAC (QUOTE ((COMS (##)))))
	    (RECORD (QUOTE STRUCLIST) (QUOTE (SFID LISTID . LISTED-THINGS)))
	    STRUCLIST?
	    (SETQ FIXEDFNLIST NIL)
	    (PUTPROP (QUOTE SFID) (QUOTE FORM) (QUOTE RECDEFAULT))
	    (PUTPROP (QUOTE LISTID) (QUOTE LIST) (QUOTE RECDEFAULT)))
VALUE)

(DEFPROP RP
 (LAMBDA (X) (PROGN (PRINT X) (READ)))
EXPR)

(DEFPROP START
 (LAMBDA NIL
  (TURNOFF (QUOTE (MOLECULES)))
  (EDITE (MOLECULES (RP (QUOTE CL)) (RP (QUOTE U))) (QUOTE (1. TTY:)) NIL))
EXPR)

(DEFPROP ARGLISTASK
 (LAMBDA(FN)
  (COND	((GET FN (QUOTE EXPR)) (ARGLIST FN))
	((GET FN (QUOTE ARGLIST)) (GET FN (QUOTE ARGLIST)))
	(T (PUTPROP FN (PROGN (PRINT FN) (PRINC (QUOTE / ARGLIST?)) (READ)) (QUOTE ARGLIST)))))
EXPR)

(DEFPROP GENAPPLY
 (LAMBDA(FORM GOLIST)
  (PROG	(ALIST NEWFORM)
	(SETQ NEWFORM (CDR FORM))
	(SETQ ALIST
	      (MAPCAR (FUNCTION
		       (LAMBDA(V)
			(CONS (OR# (GET V (QUOTE EXPANDFLAG))
				   (QUOTE DUMMY-VARIABLE-BECAUSE-NIL-CANNOT-BE-REBOUND))
			      NIL)))
		      (CONS (CAR NEWFORM) GOLIST)))
	(SETQ NEWFORM
	      (CONS (CAR NEWFORM) (MAPCAR (FUNCTION (LAMBDA (X) (LIST (QUOTE QUOTE) X))) (CDR NEWFORM))))
   LP	(RETURN
	 (SELECTQ (GETVAL (CAR NEWFORM) NIL)
		  (STRUC (EVAL NEWFORM ALIST))
		  (LSTRUC (MAKELIST (EVAL NEWFORM ALIST)))
		  (HELP)))))
EXPR)

(DEFPROP GETDEF
 (LAMBDA (X) (AND# (ATOM X) (OR# (GET X (QUOTE EXPR)) (GET X (QUOTE SUBR)))))
EXPR)

(DEFPROP FIXFN
 (LAMBDA(FN VALTYPE STRUCCHECK CONDITIONS)
  (PROGN (COND ((NOT (GETDEF FN)) (ERROR FN (QUOTE "NOT A FUNCTION"))))
	 (PROG (NEWVALTYPE FNFLAG FIXED WD CHECKVAR CONDITION)
	       (SETQ FIXED (GET FN (QUOTE FIXED)))
	       (SETQ FNFLAG
		     (OR# (GET FN (QUOTE EXPANDFLAG)) (PUTPROP FN (PACK FN (GENSYM)) (QUOTE EXPANDFLAG))))
	       (SETQ NEWVALTYPE (GETVAL FN VALTYPE))
	       (COND
		(FIXED (PRINC FN)
		       (PRINC (QUOTE " ALREADY FIXED.
EDIT INSTEAD:"))       (PRINC FIXED)
		       (TERPRI)
		       (EDITE FIXED NIL NIL)
		       (RETURN FN)))
	       (SET FNFLAG T)
	       (SETQ FIXED (LIST FNFLAG))
	       (COND
		((NUMBERP
		  (SETQ	CHECKVAR
			(OR# STRUCCHECK
			     (PROGN (PRINC FN) (PRINC (QUOTE "CHECK FOR STRUCFORM IN # ARG?")) (READ)))))
		 (SETQ FIXED (CONS (LIST (QUOTE STRUCFORM?) (CAR (NTH (ARGLIST FN) CHECKVAR))) FIXED))))
	       (COND (CONDITIONS (SETQ FIXED (REMOVE NIL (APPEND CONDITIONS FIXED))))
		     (T
		      (PROG NIL
			    (PRINC (QUOTE "ADD EXTRA CONDITION?"))
		       LP   (COND
			     ((SETQ CONDITION (READ))
			      (SETQ FIXED (CONS CONDITION FIXED))
			      (PRINC (QUOTE "CONDITION? "))
			      (GO LP))))))
	  NOEXTRA
	       (PUTPROP	FN
			(SETQ FIXED
			      (LIST (QUOTE COND)
				    (LIST (COND ((CDR FIXED) (CONS (QUOTE OR#) FIXED)) (T (CAR FIXED)))
					  (LIST	(QUOTE RETURN)
						(SELECTQ NEWVALTYPE
							 (LSTRUC (LIST (QUOTE LIST) (MAKEMAKEFORM FN)))
							 (MAKEMAKEFORM FN))))))
			(QUOTE FIXED))
	       (ADVISE1 FN (QUOTE BEFORE) (ARGLISTASK FN) FIXED)
	       (SETQ FIXEDFNLIST (CONS FN FIXEDFNLIST)))
	 FN))
EXPR)

(DEFPROP UNFIXFN
 (LAMBDA(FN)
  (PROGN (RPLACD (GETP FN (QUOTE FIXED))) (REMPROP FN (QUOTE VALTYPE)) (REMPROP FN (QUOTE EXPANDFLAG))))
EXPR)

(DEFPROP ISFORM
 (LAMBDA (AT) (STRUCFORM? EXPRESSION))
EXPR)

(DEFPROP GENEXPANSION
 (LAMBDA(FORM ZEROFORM UPFORM)
  (COND	((NUMBERP (CDR ZEROFORM))
	 (MAKELIST
	  (FOR NEW
	       L
	       IN
	       (GROUPRADS (LIST (CONS (CDDR FORM) (CDR ZEROFORM))))
	       LIST
	       (LSUBST (CLCREATE L) ZEROFORM UPFORM))))
	((STRUCLIST? UPFORM) (LSUBST (LISTED-THINGS FORM) FORM UPFORM))
	(T (MAKELIST (FOR NEW L IN (CDDR FORM) LIST (SUBST L FORM UPFORM))))))
EXPR)

(DEFPROP MAKELIST
 (LAMBDA(MAKELISTVAR)
  ((LAMBDA (L) (COND ((CDR L) (STRUCLIST LISTED-THINGS = L)) (T (CAR L))))
   (MAPCONC (FUNCTION (LAMBDA (Y) (COND ((STRUCLIST? Y) (APPEND (LISTED-THINGS Y))) (T (LIST Y)))))
	    MAKELISTVAR)))
EXPR)

(DEFPROP GETVAL
 (LAMBDA(FN VALTYPE)
  (OR# (AND# (NOT VALTYPE) (GET FN (QUOTE VALTYPE)))
       (PUTPROP	FN
		(SELECTQ (OR# VALTYPE (PROGN (PRINC FN) (PRINC (QUOTE " VALUE TYPE (LIST/SINGLE)?")) (READ)))
			 (L (QUOTE LSTRUC))
			 (QUOTE STRUC))
		(QUOTE VALTYPE))))
EXPR)

(DEFPROP KWOTE
 (LAMBDA (X) (LIST (QUOTE QUOTE) X))
EXPR)

(DEFPROP MAKEMAKEFORM
 (LAMBDA (FN) (CONS (QUOTE LIST) (CONS (QUOTE (QUOTE FORM)) (CONS (KWOTE FN) (ARGLISTASK FN)))))
EXPR)

(DEFPROP TURNON
 (LAMBDA(FN)
  (PROGN (COND ((NOT FN) (SETQ FN FIXEDFNLIST)))
	 (COND ((ATOM FN) (COND ((NOT (GET FN (QUOTE FIXED))) (FIXFN FN NIL NIL NIL)))
			  (SET (GET FN (QUOTE EXPANDFLAG)) NIL)
			  FN)
	       (T (MAPCAR (FUNCTION TURNON) FN)))))
EXPR)

(DEFPROP TURNOFF
 (LAMBDA(FN)
  (PROGN (COND ((NOT FN) (SETQ FN FIXEDFNLIST)))
	 (COND ((ATOM FN) (COND ((NOT (GET FN (QUOTE FIXED))) (FIXFN FN NIL NIL NIL)))
			  (SET (GET FN (QUOTE EXPANDFLAG)) T)
			  FN)
	       (T (MAPCAR (FUNCTION TURNOFF) FN)))))
EXPR)

(DEFPROP NOFORMIN
 (LAMBDA (X) (OR# (NOT (CONSP X)) (AND# (NOT (STRUCFORM? X)) (AND (NOFORMIN (CAR X)) (NOFORMIN (CDR X))))))
EXPR)

(DEFPROP STRUCINCL
 (LAMBDA (CL) (FOR NEW X IN CL OR (STRUCFORM? (CAR X))))
EXPR)

(DEFPROP STRUCINLIST
 (LAMBDA (LIST) (FOR NEW ITEM IN LIST OR (STRUCFORM? ITEM)))
EXPR)

(DEFPROP WHERE
 (LAMBDA(EXPRESSION)
  (PROGN (PRINC (QUOTE "LEVEL "))
	 (PRINC LEVEL)
	 (COND
	  ((CONSP WHICH) (PRINC (COND ((EQ (SUB1 LEVEL) (CDR WHICH)) (QUOTE ", #")) (T (QUOTE " WITHIN #"))))
			 (PRINC (CAR WHICH))
			 (PRINC (QUOTE " AT LEVEL "))
			 (PRINC (CDR WHICH))))
	 (COND ((STRUCLIST? EXPRESSION)
		(PROG (FORMS LISTS OTHER STRUCS)
		      (FOR NEW
			   X
			   IN
			   (LISTED-THINGS EXPRESSION)
			   AS
			   NEW
			   I
			   :=
			   (1. 99999.)
			   DO
			   (COND ((STRUCLIST? X) (SETQ LISTS (CONS I LISTS)))
				 ((STRUCFORM? X) (SETQ FORMS (CONS I FORMS)))
				 ((STRUCTURE? X) (SETQ STRUCS (CONS I STRUCS)))
				 (T (SETQ OTHER (CONS I OTHER)))))
		      (COND (FORMS (PRINC (QUOTE ", FORMS:")) (PRINNUMLIS FORMS)))
		      (COND (LISTS (PRINC (QUOTE ", SUBLISTS:")) (PRINNUMLIS LISTS)))
		      (COND (STRUCS (PRINC (QUOTE ", STRUCTURES:")) (PRINNUMLIS STRUCS)))
		      (COND (OTHER (PRINC (QUOTE ", RADS?:")) (PRINNUMLIS OTHER)))
		      (TERPRI)))
	       ((STRUCFORM? EXPRESSION)
		(PRINC (QUOTE ", "))
		(PRINC (CAR (FORM EXPRESSION)))
		(PRINC (QUOTE " EXPRESSION
")))	       ((STRUCTURE? EXPRESSION) (PRINC (QUOTE ", STRUCTURE.
")))	       (T (PRINC (QUOTE ", RADICAL.
"))))))
EXPR)

(DEFPROP PRINNUMLIS
 (LAMBDA(X)
  (PROGN (SETQ X (REVERSE X))
	 (PROG (LST)
	       (PRINC (SETQ LST (CAR X)))
	       (AND# X
		     (PROG (FLG)
		      LP   (SETQ X (CDR X))
			   (FOR X ON X WHILE (EQ (CAR X) (SETQ LST (ADD1 LST))) DO (SETQ FLG (CAR X)))
			   (COND (FLG (PRINC (QUOTE "-")) (PRINC FLG)))
			   (COND ((NULL X) (RETURN NIL)))
			   (PRINC (QUOTE ","))
			   (PRINC (SETQ LST (CAR X)))
			   (GO LP))))))
EXPR)

(DEFPROP STATE
 (LAMBDA(FN)
  (PROGN (COND ((NOT FN) (SETQ FN FIXEDFNLIST)))
	 (COND ((CONSP FN) (MAPCAR (FUNCTION STATE) FN))
	       (T
		(CONS FN
		      (CONS (QUOTE IS)
			    (COND ((AND (SETQ FN (GET FN (QUOTE EXPANDFLAG))) (GET FN (QUOTE VALUE)))
				   (SELECTQ (CDR (GET FN (QUOTE VALUE)))
					    (T (QUOTE (OFF)))
					    (NIL (QUOTE (ON)))
					    (NOBIND (QUOTE (NOT FIXED)))
					    (QUOTE (IN SOME WIERD STATE))))
				  (T (QUOTE (NOT FIXED))))))))))
EXPR)

(DEFPROP MMAC
 (MMAC COMSQ
       (M FORGET (E (SETQ UNDOLST (SETQ UNDOLST1 (SETQ LASTP1 (SETQ LASTP2 (SETQ LASTTAIL NIL))))) T))
       (M UPFORM 0. (← FORM))
       (M EXPAND
	  (ORR ((IF (STRUCLIST? (##))
		    ((BIND (E (SETQ #1 (GENEXPANSION (##) (## !0) (## UPFORM))) T)
			   UPFORM
			   (BI 1. -1.)
			   (I 1. #1)
			   (BO 1.)))))
	       ((IF (STRUCFORM? (##)) ((BIND (E (SETQ #1 (GENAPPLY (##) NIL)) T) (LI 1.) (I 1. #1) (BO 1.)))))
	       ((E (QUOTE CAN'T)))))
       (M !EXPAND
	  (ORR ((IF (STRUCLIST? (##))
		    ((BIND (E (SETQ #1 (GENEXPANSION (##) (## !0) (## UPFORM))) T)
			   UPFORM
			   (BI 1. -1.)
			   (I 1. #1)
			   (BO 1.)))))
	       ((IF (STRUCFORM? (##))
		    ((BIND (E (SETQ #1 (GENAPPLY (##) FIXEDFNLIST)) T) (LI 1.) (I 1. #1) (BO 1.)))))
	       ((E (QUOTE CAN'T)))))
       (M ISFORM (IF (FORM (##))))
       (M NEXTFORM (ORR (F FORM) (UPFORM)))
       (M NEXFORM (ORR (ISFORM) (NEXTFORM)))
       (M (GROUP)
	  (X Y)
	  (COMS (SUBPAIR (QUOTE (Z W)) (LIST (PLUS X 2.) (PLUS Y 2.)) (QUOTE (EMBED (Z THRU W) IN FORM LIST)))))
       (M !!EXPAND (LCL (LPQ ↑ FORMNOFORM !EXPAND)))
       (M DO !!EXPAND (IF (NOT (STRUCLIST? (##))) (!EXPAND) NIL))
       (M FORMNOFORM (LC FORM (IF (NOFORMIN (CDR (##))))))
       (M Q (MBD QUOTE))
       (M SLEVEL MARK (E (SETQ LEVEL 0.) T) (LPQ UPFORM (E (SETQ LEVEL (ADD1 LEVEL)) T)) ←←)
       (M (MAC)
	  Z
	  (COMS
	   (PUTPROP (COND ((ATOM (CAR (QUOTE Z))) (CAR (QUOTE Z))) (T (CAAR (QUOTE Z))))
		    (QUOTE (M . Z))
		    (QUOTE EDITMACRO))))
       (M AT (IF (EQ (## 0. 1.) (##)) (0.) (UP)) 1. SWHICH SLEVEL (E (WHERE (##)) T))
       (M (#) (X) (IF (NUMBERP (QUOTE X)) ((COMS (PLUS X 2.))) (E (QUOTE ?))))
       (M ARGS (E (CDR (##))))
       (M ≠ FORMNOFORM)
       (M D (LCL NEXTFORM))
       (M SWHICH
	  MARK
	  (ORR ((E (SETQ WHICH) T)
		(LC UP (E (SETQ WHICH (LENGTH (##))) T) 0. (IF (STRUCLIST? (##)) (NIL)))
		(E (SETQ WHICH (PLUS -1. (LENGTH (##)) (MINUS WHICH))) T)
		(E (PROG (LEVEL) (## SLEVEL) (SETQ WHICH (CONS WHICH LEVEL))) T))
	       (NIL))
	  ←←)
       (M (FN) (X) F (FORM X --))
       (M U UPFORM)
       (M EXPLAINALL (E (PROG (EXPLAINALL) (SETQ EXPLAINALL T) (## EXPLAIN)) T))
       (M - (ORR (NX) (!NX)))
       (M EVALTHIS (E (EVAL (##))))
       (M QUOTIT (I : (QUOTEIT1 (## UP 1.))) 1.)
       (M (EVALTHIS) X (ORR ((LC . X) EVALTHIS) (E (QUOTE CAN'T)))))
VALUE)

(EDITE MMAC (QUOTE ((COMS (##)))))

(RECORD (QUOTE STRUCLIST) (QUOTE (SFID LISTID . LISTED-THINGS)))

(DEFPROP STRUCLIST?
 (LAMBDA (L) (SUBST (CADR L) (QUOTE X) (QUOTE (AND# (STRUCFORM? X) (EQ (LISTID X) (QUOTE LIST))))))
MACRO)

(SETQ FIXEDFNLIST NIL)

(PUTPROP (QUOTE SFID) (QUOTE FORM) (QUOTE RECDEFAULT))

(PUTPROP (QUOTE LISTID) (QUOTE LIST) (QUOTE RECDEFAULT))